home *** CD-ROM | disk | FTP | other *** search
/ Night Owl 6 / Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso / 039a / mawk10.zip / EXECUTE.C < prev    next >
C/C++ Source or Header  |  1991-10-05  |  30KB  |  1,063 lines
  1.  
  2. /********************************************
  3. execute.c
  4. copyright 1991, Michael D. Brennan
  5.  
  6. This is a source file for mawk, an implementation of
  7. the AWK programming language.
  8.  
  9. Mawk is distributed without warranty under the terms of
  10. the GNU General Public License, version 2, 1991.
  11. ********************************************/
  12.  
  13. /* $Log:    execute.c,v $
  14.  * Revision 3.6.1.1  91/09/14  17:23:03  brennan
  15.  * VERSION 1.0
  16.  * 
  17.  * Revision 3.6  91/08/16  11:01:26  brennan
  18.  * Carl's addition of SW_FP_CHECK for V7 XNX23A
  19.  * 
  20.  * Revision 3.5  91/08/13  06:51:08  brennan
  21.  * VERSION .9994
  22.  * 
  23.  * Revision 3.4  91/06/28  04:16:28  brennan
  24.  * VERSION 0.999
  25.  * 
  26.  * Revision 3.3  91/06/19  10:23:28  brennan
  27.  * changes for xenix_r2, call this version 0.997
  28.  * 
  29.  * Revision 3.2  91/06/15  09:12:22  brennan
  30.  * Carl's diffs for V7
  31.  * 
  32.  * 06/12/91  C. Mascott        use D2BOOL macro for logical
  33.  *                  test on double
  34.  *
  35.  * Revision 3.1  91/06/07  10:27:14  brennan
  36.  * VERSION 0.995
  37.  * 
  38.  * Revision 2.5  91/05/23  15:45:44  brennan
  39.  * fixed bug in _TEST:  case C_STRNUM
  40.  * 
  41.  * Revision 2.4  91/05/22  07:43:29  brennan
  42.  * small change to work around bug in TurboC++
  43.  * 
  44.  * Revision 2.3  91/05/15  12:07:31  brennan
  45.  * dval hash table for arrays
  46.  * 
  47.  * Revision 2.2  91/04/09  12:38:54  brennan
  48.  * added static to funct decls to satisfy STARDENT compiler
  49.  * 
  50.  * Revision 2.1  91/04/08  08:22:55  brennan
  51.  * VERSION 0.97
  52.  * 
  53. */
  54.  
  55.  
  56. #include "mawk.h"
  57. #include "code.h"
  58. #include "memory.h"
  59. #include "symtype.h"
  60. #include "field.h"
  61. #include "bi_funct.h"
  62. #include "regexp.h"
  63. #include "repl.h"
  64. #include <math.h>
  65.  
  66. /* static functions */
  67. static int PROTO( compare, (CELL *) ) ;
  68. static void PROTO( eval_overflow, (void) ) ;
  69.  
  70.  
  71. #if   NOINFO_SIGFPE
  72. static char dz_msg[] = "division by zero" ;
  73. #endif
  74.  
  75. #ifdef   DEBUG
  76. #define  inc_sp()   if( ++sp == eval_stack+EVAL_STACK_SIZE )\
  77.                          eval_overflow()
  78. #else
  79.  
  80. /* If things are working, the only reason the eval stack should
  81.    overflow is too much function recursion
  82.    (checked for at _CALL below  */
  83.  
  84. #define inc_sp()    sp++
  85. #endif
  86.  
  87. #define  SAFETY    3    /* if we get within 3 of stack top emit 
  88.          overflow */
  89.  
  90. /*  The stack machine that executes the code */
  91.  
  92. CELL  eval_stack[EVAL_STACK_SIZE] ;
  93.  
  94. static void eval_overflow()
  95. { overflow("eval stack" , EVAL_STACK_SIZE) ; mawk_exit(1) ; }
  96.  
  97. /* if this flag is on, recursive calls to execute need to
  98.    return to the _CALL statement.  This only happens
  99.    inside array loops */
  100. int  returning ;  
  101.  
  102. INST  *execute(cdp, sp, fp)
  103.   register INST *cdp ;  /* code ptr, start execution here */
  104.   register CELL *sp ;   /* eval_stack pointer */
  105.   CELL *fp ;            /* frame ptr into eval_stack for
  106.                            user defined functions */
  107. { 
  108.   /* some useful temporaries */
  109.   CELL *cp , tc ;
  110.   int t ;
  111.  
  112. #ifdef  DEBUG
  113.   CELL *entry_sp = sp ;
  114. #endif
  115.  
  116.   while ( 1 )
  117.     switch( cdp++ -> op )
  118.     {   case  _HALT :
  119.         case  _STOP :  
  120.  
  121. #ifdef   DEBUG
  122. /* check the stack is sane */
  123.                 if ( sp != entry_sp ) bozo("stop") ;
  124.                 return cdp - 1 ;
  125.  
  126.         case  _STOP0  : /* if debugging stops range patterns */
  127.                 if ( sp != entry_sp+1 ) bozo("stop0") ;
  128. #else
  129.         case  _STOP0  :
  130. #endif
  131.                 return cdp -  1 ;
  132.  
  133.         case  _PUSHC :  
  134.             inc_sp() ;
  135.             (void) cellcpy(sp, cdp++ -> ptr) ;
  136.             break ;
  137.  
  138.         case  F_PUSHA :
  139.             if ( (CELL*)cdp->ptr != field && nf < 0 ) split_field0() ;
  140.             /* fall thru */
  141.  
  142.         case  _PUSHA :
  143.         case  A_PUSHA :
  144.             inc_sp() ;
  145.             sp -> ptr = cdp++ -> ptr ;
  146.             break ;
  147.  
  148.         case _PUSHI :  /* put contents of next address on stack*/
  149.             inc_sp() ;
  150.             (void) cellcpy(sp, cdp++ -> ptr) ;
  151.             break ;
  152.             
  153.         case L_PUSHI :  
  154.             /* put the contents of a local var on stack,
  155.                cdp->op holds the offset from the frame pointer */
  156.             inc_sp() ;
  157.             (void) cellcpy(sp, fp + cdp++->op) ;
  158.             break ;
  159.  
  160.         case L_PUSHA : /* put a local address on eval stack */
  161.             inc_sp() ;
  162.             sp->ptr = (PTR)(fp + cdp++->op) ;
  163.             break ;
  164.  
  165.  
  166.         case F_PUSHI :
  167.  
  168.         /* note $0 , RS , FS and OFMT are loaded by _PUSHI */
  169.  
  170.             inc_sp() ;
  171.             if ( nf < 0 )  split_field0() ;
  172.             if ( (t = (CELL *) cdp->ptr - field) <= nf ||
  173.                   t == NF  )
  174.             { (void) cellcpy(sp, cdp++ -> ptr) ; }
  175.             else  /* an unset field */
  176.             { sp->type = C_STRING ;
  177.               sp->ptr = (PTR) & null_str ;
  178.               null_str.ref_cnt++ ;
  179.               cdp++ ;
  180.             }
  181.             break ;
  182.  
  183.         case  FE_PUSHA :
  184.             if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  185.             if ( (t = (int) sp->dval) < 0 )
  186.                 rt_error( "negative field index(%d)", t) ;
  187.             if ( t > MAX_FIELD )
  188.                 rt_overflow("MAX_FIELD", MAX_FIELD) ;
  189.             if ( t && nf < 0 )  split_field0() ;
  190.             sp->ptr = (PTR) &field[t] ;
  191.             break ;
  192.  
  193.         case  FE_PUSHI :
  194.             if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  195.  
  196.             if ( (t = (int) sp->dval) == 0 )
  197.             { (void) cellcpy(sp, &field[0]) ; break ; }
  198.  
  199.             if ( t < 0 )
  200.                   rt_error( "negative field index(%d)", t) ;
  201.             if ( t > MAX_FIELD )
  202.                   rt_overflow("MAX_FIELD", MAX_FIELD) ;
  203.  
  204.             if ( nf < 0)  split_field0() ;
  205.             if ( t <= nf ) (void) cellcpy(sp, &field[t]) ;
  206.             else
  207.             { sp->type = C_STRING ;
  208.               sp->ptr = (PTR) & null_str ;
  209.               null_str.ref_cnt++ ;
  210.             }
  211.             break ; 
  212.  
  213.  
  214.         case  AE_PUSHA :
  215.         /* top of stack has an expr, cdp->ptr points at an
  216.            array, replace the expr with the cell address inside
  217.            the array */
  218.  
  219.             cp = array_find((ARRAY)cdp++->ptr, sp, CREATE) ;
  220.             cell_destroy(sp) ;
  221.             sp->ptr = (PTR) cp ;
  222.             break ;
  223.  
  224.         case  AE_PUSHI :
  225.         /* top of stack has an expr, cdp->ptr points at an
  226.            array, replace the expr with the contents of the
  227.            cell inside the array */
  228.  
  229.             cp = array_find((ARRAY) cdp++->ptr, sp, CREATE) ;
  230.             cell_destroy(sp) ;
  231.             (void) cellcpy(sp, cp) ;
  232.             break ;
  233.  
  234.         case  LAE_PUSHI :
  235.         /*  sp[0] is an expression
  236.             cdp->op is offset from frame pointer of a CELL which
  237.                has an ARRAY in the ptr field, replace expr
  238.             with  array[expr]
  239.         */
  240.             cp = array_find( (ARRAY)fp[cdp++->op].ptr, sp, CREATE) ;
  241.             cell_destroy(sp) ;
  242.             (void) cellcpy(sp, cp) ;
  243.             break ;
  244.             
  245.         case  LAE_PUSHA :
  246.         /*  sp[0] is an expression
  247.             cdp->op is offset from frame pointer of a CELL which
  248.                has an ARRAY in the ptr field, replace expr
  249.             with  & array[expr]
  250.         */
  251.             cp = array_find( (ARRAY)fp[cdp++->op].ptr, sp, CREATE) ;
  252.             cell_destroy(sp) ;
  253.             sp->ptr = (PTR) cp ;
  254.             break ;
  255.             
  256.         case  LA_PUSHA  :
  257.         /*  cdp->op is offset from frame pointer of a CELL which
  258.                has an ARRAY in the ptr field. Push this ARRAY
  259.                on the eval stack
  260.         */
  261.             inc_sp() ;
  262.             sp->ptr = fp[cdp++->op].ptr ;
  263.             break ;
  264.  
  265.         case  A_LOOP :
  266.             cdp = array_loop(cdp,sp,fp) ;
  267.             if ( returning ) return cdp ; /*value doesn't matter*/
  268.             sp -= 2 ;
  269.             break ;
  270.  
  271.         case  _POP : 
  272.             cell_destroy(sp) ;
  273.             sp-- ;
  274.             break ;
  275.  
  276.         case _DUP  :
  277.             (void) cellcpy(sp+1, sp) ;
  278.             sp++ ; break ;
  279.  
  280.         case  _ASSIGN :
  281.             /* top of stack has an expr, next down is an
  282.                address, put the expression in *address and
  283.                replace the address with the expression */
  284.  
  285.             /* don't propagate type C_MBSTRN */
  286.             if ( sp->type == C_MBSTRN ) check_strnum(sp) ;
  287.             sp-- ;
  288.             cell_destroy( ((CELL *)sp->ptr) ) ;
  289.             (void) cellcpy( sp, cellcpy(sp->ptr, sp+1) ) ;
  290.             cell_destroy(sp+1) ;
  291.             break ;
  292.  
  293.         case  F_ASSIGN : /* assign to a field  */
  294.             if (sp->type == C_MBSTRN) check_strnum(sp) ;
  295.             sp-- ;
  296.             field_assign((CELL*)sp->ptr - field, sp+1) ;
  297.             cell_destroy(sp+1) ;
  298.             (void) cellcpy(sp, (CELL *) sp->ptr) ;
  299.             break ;
  300.  
  301.         case  _ADD_ASG:
  302.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  303.             cp = (CELL *) (sp-1)->ptr ;
  304.             if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
  305.  
  306. #if SW_FP_CHECK   /* specific to V7 and XNX23A */
  307.             clrerr();
  308. #endif
  309.             cp->dval += sp-- -> dval ;
  310. #if SW_FP_CHECK
  311.             fpcheck();
  312. #endif
  313.             sp->type = C_DOUBLE ;
  314.             sp->dval = cp->dval ;
  315.             break ;
  316.  
  317.         case  _SUB_ASG:
  318.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  319.             cp = (CELL *) (sp-1)->ptr ;
  320.             if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
  321. #if SW_FP_CHECK
  322.             clrerr();
  323. #endif
  324.             cp->dval -= sp-- -> dval ;
  325. #if SW_FP_CHECK
  326.             fpcheck();
  327. #endif
  328.             sp->type = C_DOUBLE ;
  329.             sp->dval = cp->dval ;
  330.             break ;
  331.  
  332.         case  _MUL_ASG:
  333.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  334.             cp = (CELL *) (sp-1)->ptr ;
  335.             if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
  336. #if SW_FP_CHECK
  337.             clrerr();
  338. #endif
  339.             cp->dval *= sp-- -> dval ;
  340. #if SW_FP_CHECK
  341.             fpcheck();
  342. #endif
  343.             sp->type = C_DOUBLE ;
  344.             sp->dval = cp->dval ;
  345.             break ;
  346.  
  347.         case  _DIV_ASG:
  348.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  349.             cp = (CELL *) (sp-1)->ptr ;
  350.             if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
  351.  
  352. #if  NOINFO_SIGFPE
  353.     CHECK_DIVZERO(sp->dval) ;
  354. #endif
  355.  
  356. #if SW_FP_CHECK
  357.             clrerr();
  358. #endif
  359.             cp->dval /= sp-- -> dval ;
  360. #if SW_FP_CHECK
  361.             fpcheck();
  362. #endif
  363.             sp->type = C_DOUBLE ;
  364.             sp->dval = cp->dval ;
  365.             break ;
  366.  
  367.         case  _MOD_ASG:
  368.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  369.             cp = (CELL *) (sp-1)->ptr ;
  370.             if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
  371.  
  372. #if  NOINFO_SIGFPE
  373.     CHECK_DIVZERO(sp->dval) ;
  374. #endif
  375.  
  376.             cp->dval = fmod(cp->dval,sp-- -> dval) ;
  377.             sp->type = C_DOUBLE ;
  378.             sp->dval = cp->dval ;
  379.             break ;
  380.  
  381.         case  _POW_ASG:
  382.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  383.             cp = (CELL *) (sp-1)->ptr ;
  384.             if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
  385.             cp->dval = pow(cp->dval,sp-- -> dval) ;
  386.             sp->type = C_DOUBLE ;
  387.             sp->dval = cp->dval ;
  388.             break ;
  389.  
  390.         /* will anyone ever use these ? */
  391.  
  392.         case F_ADD_ASG :
  393.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  394.             cp = (CELL *) (sp-1)->ptr ;
  395.             cast1_to_d( cellcpy(&tc, cp) ) ;
  396. #if SW_FP_CHECK
  397.             clrerr();
  398. #endif
  399.             tc.dval += sp-- -> dval ;
  400. #if SW_FP_CHECK
  401.             fpcheck();
  402. #endif
  403.             sp->type = C_DOUBLE ;
  404.             sp->dval = tc.dval ;
  405.             field_assign(cp-field, &tc) ;
  406.             break ;
  407.  
  408.         case F_SUB_ASG :
  409.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  410.             cp = (CELL *) (sp-1)->ptr ;
  411.             cast1_to_d( cellcpy(&tc, cp) ) ;
  412. #if SW_FP_CHECK
  413.             clrerr();
  414. #endif
  415.             tc.dval -= sp-- -> dval ;
  416. #if SW_FP_CHECK
  417.             fpcheck();
  418. #endif
  419.             sp->type = C_DOUBLE ;
  420.             sp->dval = tc.dval ;
  421.             field_assign(cp-field, &tc) ;
  422.             break ;
  423.  
  424.         case F_MUL_ASG :
  425.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  426.             cp = (CELL *) (sp-1)->ptr ;
  427.             cast1_to_d( cellcpy(&tc, cp) ) ;
  428. #if SW_FP_CHECK
  429.             clrerr();
  430. #endif
  431.             tc.dval *= sp-- -> dval ;
  432. #if SW_FP_CHECK
  433.             fpcheck();
  434. #endif
  435.             sp->type = C_DOUBLE ;
  436.             sp->dval = tc.dval ;
  437.             field_assign(cp-field, &tc) ;
  438.             break ;
  439.  
  440.         case F_DIV_ASG :
  441.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  442.             cp = (CELL *) (sp-1)->ptr ;
  443.             cast1_to_d( cellcpy(&tc, cp) ) ;
  444.  
  445. #if  NOINFO_SIGFPE
  446.     CHECK_DIVZERO(sp->dval) ;
  447. #endif
  448.  
  449. #if SW_FP_CHECK
  450.             clrerr();
  451. #endif
  452.             tc.dval /= sp-- -> dval ;
  453. #if SW_FP_CHECK
  454.             fpcheck();
  455. #endif
  456.             sp->type = C_DOUBLE ;
  457.             sp->dval = tc.dval ;
  458.             field_assign(cp-field, &tc) ;
  459.             break ;
  460.  
  461.         case F_MOD_ASG :
  462.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  463.             cp = (CELL *) (sp-1)->ptr ;
  464.             cast1_to_d( cellcpy(&tc, cp) ) ;
  465.  
  466. #if  NOINFO_SIGFPE
  467.     CHECK_DIVZERO(sp->dval) ;
  468. #endif
  469.  
  470.             tc.dval = fmod(tc.dval, sp-- -> dval) ;
  471.             sp->type = C_DOUBLE ;
  472.             sp->dval = tc.dval ;
  473.             field_assign(cp-field, &tc) ;
  474.             break ;
  475.  
  476.         case F_POW_ASG :
  477.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  478.             cp = (CELL *) (sp-1)->ptr ;
  479.             cast1_to_d( cellcpy(&tc, cp) ) ;
  480.             tc.dval = pow(tc.dval, sp-- -> dval) ;
  481.             sp->type = C_DOUBLE ;
  482.             sp->dval = tc.dval ;
  483.             field_assign(cp-field, &tc) ;
  484.             break ;
  485.  
  486.         case _ADD :
  487.             sp-- ;
  488.             if ( TEST2(sp) != TWO_DOUBLES )
  489.                     cast2_to_d(sp) ;
  490. #if SW_FP_CHECK
  491.             clrerr();
  492. #endif
  493.             sp[0].dval += sp[1].dval ;
  494. #if SW_FP_CHECK
  495.             fpcheck();
  496. #endif
  497.             break ;
  498.  
  499.         case _SUB :
  500.             sp-- ;
  501.             if ( TEST2(sp) != TWO_DOUBLES )
  502.                     cast2_to_d(sp) ;
  503. #if SW_FP_CHECK
  504.             clrerr();
  505. #endif
  506.             sp[0].dval -= sp[1].dval ;
  507. #if SW_FP_CHECK
  508.             fpcheck();
  509. #endif
  510.             break ;
  511.  
  512.         case _MUL :
  513.             sp-- ;
  514.             if ( TEST2(sp) != TWO_DOUBLES )
  515.                     cast2_to_d(sp) ;
  516. #if SW_FP_CHECK
  517.             clrerr();
  518. #endif
  519.             sp[0].dval *= sp[1].dval ;
  520. #if SW_FP_CHECK
  521.             fpcheck();
  522. #endif
  523.             break ;
  524.  
  525.         case _DIV :
  526.             sp-- ;
  527.             if ( TEST2(sp) != TWO_DOUBLES )
  528.                     cast2_to_d(sp) ;
  529.  
  530. #if  NOINFO_SIGFPE
  531.     CHECK_DIVZERO(sp[1].dval) ;
  532. #endif
  533.  
  534. #if SW_FP_CHECK
  535.             clrerr();
  536. #endif
  537.             sp[0].dval /= sp[1].dval ;
  538. #if SW_FP_CHECK
  539.             fpcheck();
  540. #endif
  541.             break ;
  542.  
  543.         case _MOD :
  544.             sp-- ;
  545.             if ( TEST2(sp) != TWO_DOUBLES )
  546.                     cast2_to_d(sp) ;
  547.  
  548. #if  NOINFO_SIGFPE
  549.     CHECK_DIVZERO(sp[1].dval) ;
  550. #endif
  551.  
  552.             sp[0].dval = fmod(sp[0].dval,sp[1].dval) ;
  553.             break ;
  554.  
  555.         case _POW :
  556.             sp-- ;
  557.             if ( TEST2(sp) != TWO_DOUBLES )
  558.                     cast2_to_d(sp) ;
  559.             sp[0].dval = pow(sp[0].dval,sp[1].dval) ;
  560.             break ;
  561.  
  562.         case _NOT :
  563.         reswitch_1:
  564.             switch( sp->type )
  565.             { case C_NOINIT :
  566.                     sp->dval = 1.0 ; break ;
  567.               case C_DOUBLE :
  568.                     sp->dval = D2BOOL(sp->dval) ? 0.0 : 1.0 ;
  569.                     break ;
  570.               case C_STRING :
  571.                     sp->dval = string(sp)->len ? 0.0 : 1.0 ;
  572.                     free_STRING(string(sp)) ;
  573.                     break ;
  574.               case C_STRNUM : /* test as a number */
  575.                     sp->dval = D2BOOL(sp->dval) ? 0.0 : 1.0 ;
  576.                     free_STRING(string(sp)) ;
  577.                     break ;
  578.               case C_MBSTRN :
  579.                     check_strnum(sp) ;
  580.                     goto reswitch_1 ;
  581.               default :
  582.                     bozo("bad type on eval stack") ;
  583.             }
  584.             sp->type = C_DOUBLE ;
  585.             break  ;
  586.  
  587.         case _TEST :
  588.         reswitch_2:
  589.             switch( sp->type )
  590.             { case C_NOINIT :
  591.                     sp->dval = 0.0 ; break ;
  592.               case C_DOUBLE :
  593.                     sp->dval = D2BOOL(sp->dval) ? 1.0 : 0.0 ;
  594.                     break ;
  595.               case C_STRING :
  596.                     sp->dval  = string(sp)->len ? 1.0 : 0.0 ;
  597.                     free_STRING(string(sp)) ;
  598.                     break ;
  599.               case C_STRNUM : /* test as a number */
  600.                     sp->dval = D2BOOL(sp->dval) ? 1.0 : 0.0 ;
  601.                     free_STRING(string(sp)) ;
  602.                     break ;
  603.               case C_MBSTRN :
  604.                     check_strnum(sp) ;
  605.                     goto reswitch_2 ;
  606.               default :
  607.                     bozo("bad type on eval stack") ;
  608.             }
  609.             sp->type = C_DOUBLE ;
  610.             break ;
  611.  
  612.         case _UMINUS :
  613.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  614.             sp->dval = - sp->dval ;
  615.             break ;
  616.  
  617.         case _UPLUS :  
  618.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  619.             break ;
  620.  
  621.         case _CAT :
  622.             { unsigned len1, len2 ;
  623.               char *str1, *str2 ;
  624.               STRING *b ;
  625.               
  626.               sp-- ;
  627.               if ( TEST2(sp) != TWO_STRINGS )
  628.                     cast2_to_s(sp) ;
  629.               str1 = string(sp)->str ;
  630.               len1 = string(sp)->len ;
  631.               str2 = string(sp+1)->str ;
  632.               len2 = string(sp+1)->len ;
  633.  
  634.               b = new_STRING((char *)0, len1+len2) ;
  635.               (void) memcpy(b->str, str1, SIZE_T(len1)) ;
  636.               (void) memcpy(b->str + len1, str2, SIZE_T(len2)) ;
  637.               free_STRING(string(sp)) ;
  638.               free_STRING( string(sp+1) ) ;
  639.  
  640.               sp->ptr = (PTR) b ;
  641.               break ;
  642.             }
  643.  
  644.         case _PUSHINT :
  645.             inc_sp() ;
  646.             sp->type = cdp++ -> op ;
  647.             break ;
  648.  
  649.         case _BUILTIN :
  650.         case _PRINT :
  651.             sp = (* (PF_CP) cdp++ -> ptr) (sp) ;
  652.             break ;
  653.  
  654.         case _POST_INC :
  655.             (void) cellcpy(sp, cp = (CELL *)sp->ptr) ;
  656.             if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
  657.             cp->dval += 1.0 ;
  658.             break ;
  659.  
  660.         case _POST_DEC :
  661.             (void) cellcpy(sp, cp = (CELL *)sp->ptr) ;
  662.             if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
  663.             cp->dval -= 1.0 ;
  664.             break ;
  665.  
  666.         case _PRE_INC :
  667.             cp = (CELL *) sp->ptr ;
  668.             if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
  669.             sp->dval = cp->dval += 1.0 ;
  670.             sp->type = C_DOUBLE ;
  671.             break ;
  672.  
  673.         case _PRE_DEC :
  674.             cp = (CELL *) sp->ptr ;
  675.             if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
  676.             sp->dval = cp->dval -= 1.0 ;
  677.             sp->type = C_DOUBLE ;
  678.             break ;
  679.  
  680.  
  681.         case F_POST_INC  :
  682.             cp = (CELL *) sp->ptr ;
  683.             (void) cellcpy(sp, cellcpy(&tc, cp) ) ;
  684.             cast1_to_d(&tc) ;
  685.             tc.dval += 1.0 ;
  686.             field_assign(cp-field, &tc) ;
  687.             break ;
  688.  
  689.         case F_POST_DEC  :
  690.             cp = (CELL *) sp->ptr ;
  691.             (void) cellcpy(sp, cellcpy(&tc, cp) ) ;
  692.             cast1_to_d(&tc) ;
  693.             tc.dval -= 1.0 ;
  694.             field_assign(cp-field, &tc) ;
  695.             break ;
  696.  
  697.         case F_PRE_INC :
  698.             cp = (CELL *) sp->ptr ;
  699.             cast1_to_d(cellcpy(&tc, cp)) ;
  700.             sp->dval = tc.dval += 1.0 ;
  701.             sp->type = C_DOUBLE ;
  702.             field_assign(cp-field, sp) ;
  703.             break ;
  704.  
  705.         case F_PRE_DEC :
  706.             cp = (CELL *) sp->ptr ;
  707.             cast1_to_d(cellcpy(&tc, cp)) ;
  708.             sp->dval = tc.dval -= 1.0 ;
  709.             sp->type = C_DOUBLE ;
  710.             field_assign(cp-field, sp) ;
  711.             break ;
  712.  
  713.         case _JMP  :
  714.             cdp += cdp->op - 1 ;
  715.             break ;
  716.  
  717.         case _JNZ  :
  718.             /* jmp if top of stack is non-zero and pop stack */
  719.             if ( test( sp ) )
  720.                 cdp += cdp->op - 1 ;
  721.             else  cdp++ ;
  722.             cell_destroy(sp) ;
  723.             sp-- ;
  724.             break ;
  725.  
  726.         case _JZ  :
  727.             /* jmp if top of stack is zero and pop stack */
  728.             if ( ! test( sp ) )
  729.                 cdp += cdp->op - 1 ;
  730.             else  cdp++ ;
  731.             cell_destroy(sp) ;
  732.             sp-- ;
  733.             break ;
  734.  
  735.     /*  the relation operations */
  736.     /*  compare() makes sure string ref counts are OK */
  737.         case  _EQ :
  738.             t = compare(--sp) ;
  739.             sp->type = C_DOUBLE ;
  740.             sp->dval = t == 0 ? 1.0 : 0.0 ;
  741.             break ;
  742.  
  743.         case  _NEQ :
  744.             t = compare(--sp) ;
  745.             sp->type = C_DOUBLE ;
  746.             sp->dval = t ? 1.0 : 0.0 ;
  747.             break ;
  748.  
  749.         case  _LT :
  750.             t = compare(--sp) ;
  751.             sp->type = C_DOUBLE ;
  752.             sp->dval = t < 0 ? 1.0 : 0.0 ;
  753.             break ;
  754.  
  755.         case  _LTE :
  756.             t = compare(--sp) ;
  757.             sp->type = C_DOUBLE ;
  758.             sp->dval = t <= 0 ? 1.0 : 0.0 ;
  759.             break ;
  760.  
  761.         case  _GT :
  762.             t = compare(--sp) ;
  763.             sp->type = C_DOUBLE ;
  764.             sp->dval = t > 0 ? 1.0 : 0.0 ;
  765.             break ;
  766.  
  767.         case  _GTE :
  768.             t = compare(--sp) ;
  769.             sp->type = C_DOUBLE ;
  770.             sp->dval = t >= 0 ? 1.0 : 0.0 ;
  771.             break ;
  772.  
  773.         case  _MATCH :
  774.             /* does sp[-1] match sp[0] as re */
  775.             if ( sp->type != C_RE )  cast_to_RE(sp) ;
  776.  
  777.             if ( (--sp)->type < C_STRING )  cast1_to_s(sp) ;
  778.             t = REtest(string(sp)->str, (sp+1)->ptr) ; 
  779.  
  780.             free_STRING(string(sp)) ;
  781.             sp->type = C_DOUBLE ;
  782.             sp->dval = t ? 1.0 : 0.0 ;
  783.             break ;
  784.  
  785.         case  A_TEST :
  786.         /* entry :  sp[0].ptr-> an array
  787.                     sp[-1]  is an expression
  788.  
  789.            we compute   expression in array  */
  790.             sp-- ;
  791.             cp = array_find( (sp+1)->ptr, sp, NO_CREATE) ;
  792.             cell_destroy(sp) ;
  793.             sp->type = C_DOUBLE ;
  794.             sp->dval = (cp!=(CELL*)0)  ? 1.0 : 0.0 ;
  795.             break ;
  796.  
  797.         case  A_DEL :
  798.         /* sp[0].ptr ->  array)
  799.            sp[-1] is an expr
  800.            delete  array[expr]  */
  801.  
  802.             array_delete(sp->ptr, sp-1) ;
  803.             cell_destroy(sp-1) ;
  804.             sp -= 2 ;
  805.             break ;
  806.         
  807.         /* form a multiple array index */
  808.         case A_CAT :
  809.             sp = array_cat(sp, cdp++->op) ;
  810.             break ;
  811.  
  812.         case  _EXIT0 :
  813.             longjmp( exit_jump, 1) ;
  814.  
  815.         case  _EXIT  :
  816.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  817.             exit_code = (int) sp->dval ;
  818.             longjmp( exit_jump, 1) ;
  819.  
  820.         case  _NEXT :
  821.             longjmp(next_jump, 1) ;
  822.  
  823.         case  _RANGE :
  824. /* test a range pattern:  pat1, pat2 { action }
  825.    entry :
  826.        cdp[0].op -- a flag, test pat1 if on else pat2
  827.        cdp[1].op -- offset of pat2 code from cdp
  828.        cdp[2].op -- offset of action code from cdp
  829.        cdp[3].op -- offset of code after the action from cdp
  830.        cdp[4] -- start of pat1 code
  831. */
  832.  
  833. #define FLAG    cdp[0].op
  834. #define PAT2    cdp[1].op
  835. #define ACTION    cdp[2].op
  836. #define FOLLOW    cdp[3].op
  837. #define PAT1      4
  838.  
  839.             if ( FLAG )  /* test again pat1 */
  840.             { 
  841.               (void) execute(cdp + PAT1,sp, fp) ;
  842.               t = test(sp+1) ;
  843.               cell_destroy(sp+1) ;
  844.               if ( t )  FLAG = 0 ;
  845.               else
  846.               { cdp += FOLLOW ;
  847.                 break ;  /* break the switch */
  848.               }
  849.             }
  850.  
  851.             /* test against pat2 and then perform the action */
  852.             (void) execute(cdp + PAT2, sp, fp) ;
  853.             FLAG  = test(sp+1) ;
  854.             cell_destroy(sp+1) ; 
  855.             cdp += ACTION ;
  856.             break ;
  857.  
  858. /* function calls  */
  859.  
  860.       case  _RET0  :
  861.             inc_sp() ;
  862.             sp->type = C_NOINIT ;
  863.             /* fall thru */
  864.  
  865.       case  _RET   :
  866.  
  867. #ifdef  DEBUG
  868.             if ( sp != entry_sp+1 ) bozo("ret") ;
  869. #endif
  870.             returning = 1 ;
  871.             return  cdp-1 ;
  872.  
  873.       case  _CALL  :
  874.  
  875.             { FBLOCK *fbp = (FBLOCK*) cdp++->ptr ;
  876.               int a_args = cdp++->op ; /* actual number of args */
  877.               CELL *nfp = sp - a_args + 1 ; /* new fp for callee */
  878.               CELL *local_p = sp+1; /* first local argument on stack */
  879.               char *type_p ;  /* pts to type of an argument */
  880.  
  881.               if ( fbp->nargs ) type_p = fbp->typev + a_args ;
  882.  
  883.               /* create space for locals */
  884.               if ( t = fbp->nargs - a_args ) /* have local args */
  885.               {
  886.                 if ( sp + t >= eval_stack + EVAL_STACK_SIZE - SAFETY )
  887.                    eval_overflow() ;
  888.  
  889.                 while ( t-- )  
  890.                 { (++sp)->type = C_NOINIT ;
  891.                   if ( *type_p++ == ST_LOCAL_ARRAY )
  892.                         sp->ptr = (PTR) new_ARRAY() ;
  893.                 }
  894.               }
  895.               type_p-- ; /* *type_p is type of last arg */ 
  896.  
  897.               (void) execute(fbp->code, sp, nfp) ;
  898. #ifdef  DEBUG
  899. if ( !returning )  bozo("call") ;
  900. #endif
  901.               returning = 0 ;
  902.  
  903.               /* cleanup the callee's arguments */
  904.               if ( sp >= nfp ) 
  905.               {
  906.                 cp = sp+1 ;  /* cp -> the function return */
  907.  
  908.                 do
  909.                 {
  910.                   if ( *type_p-- == ST_LOCAL_ARRAY )
  911.                   {  if ( sp >= local_p ) array_free(sp->ptr) ; }
  912.                   else  cell_destroy(sp) ;
  913.  
  914.                 } while ( --sp >= nfp ) ;
  915.                     
  916.                 (void) cellcpy(++sp, cp) ;
  917.                 cell_destroy(cp) ;
  918.               }
  919.               else  sp++ ; /* no arguments passed */
  920.             }
  921.             break ;
  922.  
  923.         default :
  924.             bozo("bad opcode") ;
  925.     }
  926. }
  927.  
  928. int test( cp )  /* test if a cell is null or not */
  929.   register CELL *cp ;
  930. { 
  931. reswitch :
  932.  
  933.   switch ( cp->type )
  934.   {
  935.     case C_NOINIT :  return  0 ;
  936.     case C_STRNUM :  /* test as a number */
  937.     case C_DOUBLE :  return  cp->dval != 0.0 ;
  938.     case C_STRING :  return  string(cp)->len ;
  939.     case C_MBSTRN :  check_strnum(cp) ; goto reswitch ;
  940.  
  941.     default :
  942.       bozo("bad cell type in call to test") ;
  943.   }
  944. }
  945.  
  946. /* compare cells at cp and cp+1 and
  947.    frees STRINGs at those cells
  948. */
  949.  
  950. static int compare(cp)
  951.   register CELL *cp ;
  952. { int k ;
  953.  
  954. reswitch :
  955.  
  956.   switch( TEST2(cp) )
  957.   { case TWO_NOINITS :  return 0 ; 
  958.     
  959.     case TWO_DOUBLES :
  960.     two_d:
  961.             return  cp->dval > (cp+1)->dval ? 1 :
  962.                     cp->dval < (cp+1)->dval ? -1 : 0 ;
  963.     
  964.     case TWO_STRINGS :
  965.     case STRING_AND_STRNUM :
  966.     two_s:
  967.             k = strcmp(string(cp)->str, string(cp+1)->str) ;
  968.             free_STRING( string(cp) ) ;
  969.             free_STRING( string(cp+1) ) ;
  970.             return k ;
  971.  
  972.     case  NOINIT_AND_DOUBLE  :
  973.     case  NOINIT_AND_STRNUM  :
  974.     case  DOUBLE_AND_STRNUM  :
  975.     case TWO_STRNUMS :
  976.             cast2_to_d(cp) ; goto two_d ;
  977.  
  978.     case  NOINIT_AND_STRING  :
  979.     case  DOUBLE_AND_STRING  :
  980.             cast2_to_s(cp) ; goto two_s ;
  981.  
  982.     case  TWO_MBSTRNS :
  983.             check_strnum(cp) ; check_strnum(cp+1) ;
  984.             goto reswitch ;
  985.  
  986.     case  NOINIT_AND_MBSTRN :
  987.     case  DOUBLE_AND_MBSTRN :
  988.     case  STRING_AND_MBSTRN :
  989.     case  STRNUM_AND_MBSTRN :
  990.             check_strnum( cp->type == C_MBSTRN ? cp : cp+1 ) ;
  991.             goto reswitch ;
  992.  
  993.     default :  /* there are no default cases */
  994.             bozo("bad cell type passed to compare") ;
  995.   }
  996. }
  997.  
  998. /* does not assume target was a cell, if so
  999.    then caller should have made a previous
  1000.    call to cell_destroy  */
  1001.  
  1002. CELL *cellcpy(target, source)
  1003.   register CELL *target, *source ;
  1004. { switch( target->type = source->type )
  1005.   { case C_NOINIT : 
  1006.     case C_SPACE  : 
  1007.     case C_SNULL  :
  1008.             break ;
  1009.  
  1010.     case C_DOUBLE :
  1011.             target->dval = source->dval ;
  1012.             break ;
  1013.  
  1014.     case C_STRNUM :
  1015.             target->dval = source->dval ;
  1016.             /* fall thru */
  1017.  
  1018.     case C_REPL    :
  1019.     case C_MBSTRN  :
  1020.     case C_STRING  :
  1021.             string(source)->ref_cnt++ ;
  1022.             /* fall thru */
  1023.  
  1024.     case C_RE  :
  1025.             target->ptr = source->ptr ;
  1026.             break ;
  1027.  
  1028.     case  C_REPLV :
  1029.             (void)  replv_cpy(target, source) ;
  1030.             break ;
  1031.  
  1032.     default :
  1033.             bozo("bad cell passed to cellcpy()") ;
  1034.             break ;
  1035.   }
  1036.   return  target ;
  1037. }
  1038.  
  1039. #ifdef   DEBUG
  1040.  
  1041. void  DB_cell_destroy(cp)    /* HANGOVER time */
  1042.   register CELL *cp ;
  1043. {
  1044.   switch( cp->type )
  1045.   { case C_NOINIT :
  1046.     case C_DOUBLE :  break ;
  1047.  
  1048.     case C_MBSTRN :
  1049.     case C_STRING :
  1050.     case C_STRNUM :
  1051.             if ( -- string(cp)->ref_cnt == 0 )
  1052.                 zfree(string(cp) , string(cp)->len+5) ;
  1053.             break ;
  1054.  
  1055.     case  C_RE :
  1056.             bozo("cell destroy called on RE cell") ;
  1057.     default :
  1058.             bozo("cell destroy called on bad cell type") ;
  1059.   }
  1060. }
  1061.  
  1062. #endif
  1063.